home *** CD-ROM | disk | FTP | other *** search
/ ADA Programming Guide / ADA Programming Guide.iso / ada_gwu / nam.c < prev    next >
C/C++ Source or Header  |  1996-01-30  |  11KB  |  386 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. #define GEN
  11.  
  12. #include "hdr.h"
  13. #include "vars.h"
  14. #include "gvars.h"
  15. #include "ops.h"
  16. #include "segment.h"
  17. #include "setp.h"
  18. #include "genp.h"
  19. #include "smiscp.h"
  20. #include "exprp.h"
  21. #include "maincasp.h"
  22. #include "gmiscp.h"
  23. #include "gutilp.h"
  24. #include "namp.h"
  25.  
  26. /* changes
  27.  * 13-mar-85    shields
  28.  * change 'index_type' to 'indx_type' since index_type is macro in sem.
  29.  */
  30.  
  31. /*
  32.  *T+ Chapter 4: Names and Expressions
  33.  *  Object expressions (used for left-hand sides) is processed
  34.  *  by GEN_ADDRESS, value expressions (used as "right-hand sides")
  35.  *  are processed by GEN_VALUE.
  36.  *
  37.  *   At run-time, the stack contains addresses of objects, but values
  38.  *   are represented either by the actual value for simple types, or
  39.  *   by pointers to data-segments for composite types.
  40.  *
  41.  *   The addresses (or pointers) are usually a pair of unsigned
  42.  *   integers: ( data_segment number, offset in that segment), except
  43.  *   for array objects and values, for which an address consists of
  44.  *   two such pairs,  ( address of array, address of descriptor ).
  45.  *
  46.  *  The format of objects on the stack at run-time are one of the
  47.  *  following (this will be called the "kind" of an object).
  48.  *
  49.  *   mu_byte : for boolean, short_integer, enumeration,
  50.  *             record field number, task
  51.  *
  52.  *   mu_word : for integer, or for an offset
  53.  *
  54.  *   mu_addr : for an absolute address (seg. number + offset)
  55.  *
  56.  *   mu_long : for long_integer and floating-point real numbers
  57.  *
  58.  *   mu_dble : for a double address (array reference)
  59.  *
  60.  *   mu_xlng : for long_float and fixed points requiring a large
  61.  *            mantissa
  62.  *
  63.  *
  64.  *  The function size_of(type) returns the size (in bytes) occupied
  65.  *  by one value of the type 'type'. The function kind_of(type) returns
  66.  *  the kind of stack reference of an object (i.e. mu_byte, mu_word,
  67.  *  mu_dble or mu_addr if the object is not a simple one (or an access).
  68.  */
  69.  
  70. /* Object evaluation */
  71. void gen_address(Node node)                                        /*;gen_address*/
  72. {
  73.     /*
  74.      *  This procedure generates code for the o_expressions
  75.      *  or, in other words, the left-handsides.
  76.      */
  77.  
  78.     Node   pre_node, array_node, range_node, lbd_node, ubd_node, record_node,
  79.       field_node, id_node;
  80.     Symbol    node_name, type_name, record_name, record_type,
  81.       field_name, comp_type, proc_name, return_type;
  82.     int        f_off, bse, off, nk;
  83.     Fortup    ft1;
  84.  
  85. #ifdef TRACE
  86.     if (debug_flag)
  87.         gen_trace_node("GEN_ADDRESS", node);
  88. #endif
  89.  
  90.     while (N_KIND(node) == as_insert) {
  91.         FORTUP(pre_node=(Node), N_LIST(node), ft1);
  92.             compile(pre_node);
  93.         ENDFORTUP(ft1);
  94.         node = N_AST1(node);
  95.     }
  96.  
  97.     node_name = N_UNQ(node);
  98.     if (is_simple_name(node)) {
  99.         type_name = get_type(node);
  100.         if (is_renaming(node_name))
  101.             gen_ks(I_PUSH, mu_addr, node_name);
  102.         else
  103.             gen_s(I_PUSH_EFFECTIVE_ADDRESS, node_name);
  104.  
  105.         /* Arrays are treated in a different manner, depending on their */
  106.         /* nature: parameters, constants, variables... */
  107.         if (is_array_type(type_name)) {
  108.             if (is_formal_parameter(node_name)) {
  109.                 type_name = assoc_symbol_get(node_name, FORMAL_TEMPLATE);
  110.             }
  111.             gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
  112.         }
  113.  
  114.     }
  115.     else {
  116.         switch (nk = N_KIND(node)) {
  117.         case as_raise:
  118.             compile(node);
  119.             break;
  120.  
  121.         case as_index:
  122.             gen_subscript(node);
  123.             break;
  124.  
  125.         case as_slice:
  126.             array_node = N_AST1(node);
  127.             range_node = N_AST2(node);
  128.             /*range_name = N_UNQ(range_node); -- never used   ds 7-8-85 */
  129.  
  130.             /* Note: case of type simple name changed into range attribute */
  131.             /* by expander */
  132.             if (N_KIND(range_node) == as_attribute) {
  133.                 gen_attribute(range_node);
  134.             }
  135.             else { /* range */
  136.                 lbd_node = N_AST1(range_node);
  137.                 ubd_node = N_AST2(range_node);
  138.                 gen_value(lbd_node);
  139.                 gen_value(ubd_node);
  140.             }
  141.             if (N_KIND(array_node) == as_attribute) {
  142.                 gen_attribute(array_node);
  143.             }
  144.             else {
  145.                 gen_address(array_node);
  146.             }
  147.             gen(I_ARRAY_SLICE);
  148.             break;
  149.  
  150.         case as_selector:
  151.             record_node = N_AST1(node);
  152.             field_node = N_AST2(node);
  153.             record_name = N_UNQ(record_node);
  154.             record_type = get_type(record_node);
  155.             field_name = N_UNQ(field_node);
  156.             f_off = FIELD_OFFSET(field_name);
  157.             if (f_off >= 0 &&
  158.               ((! has_discriminant(record_type))
  159.               || NATURE(field_name) == na_discriminant)){
  160.                 if (is_simple_name(record_node)
  161.                   && !(is_renaming(record_name)) && is_global(record_name)) {
  162.                     reference_of(record_name);
  163.                     bse = REFERENCE_SEGMENT;
  164.                     off = REFERENCE_OFFSET;
  165.                     /* The SETL version has generate(I_PUSH_IMMEDIATE, mu_addr,
  166.                      *  ref, field_name);
  167.                      * which we translate as (I_PUSH_EFFECTIVE_ADDRESS ...
  168.                      * ref       = [bse, off+f_off];
  169.                      * Replace use of explicit ref by PUSH_IMMEDIATE
  170.                      */
  171.                     /*  gen_rc(I_PUSH_IMMEDIATE, explicit_ref_new(bse,
  172.                      *   off+f_off), "");
  173.                      */
  174.                     gen_kv(I_PUSH_IMMEDIATE, mu_word, int_const(bse));
  175.                     gen_kv(I_PUSH_IMMEDIATE, mu_word, int_const(off+f_off));
  176.                 }
  177.                 else {
  178.                     gen_address(record_node);
  179.                     if (f_off != 0 ) {
  180.                         gen_ki(I_ADD_IMMEDIATE, mu_word, f_off);
  181.                     }
  182.                 }
  183.                 if (is_array_type(comp_type=TYPE_OF(field_name))) {
  184.                     gen_s(I_PUSH_EFFECTIVE_ADDRESS, comp_type);
  185.                 }
  186.             }
  187.             else {
  188.                 gen_address(record_node);
  189.                 gen_s(I_PUSH_EFFECTIVE_ADDRESS, record_type);
  190.                 /* translating following assuming field_name is comment part of
  191.                  *-- instruction        ds    7-5-86
  192.                  *         gen_i(I_SELECT, FIELD_NUMBER(field_name), field_name);
  193.                  */
  194.                 gen_i(I_SELECT, (int) FIELD_NUMBER(field_name));
  195.             }
  196.             break;
  197.  
  198.         case as_all:
  199.             id_node = N_AST1(node);
  200.             gen_value(id_node);
  201.             if (is_array_type(N_TYPE(node)))
  202.                 gen_k(I_DEREF, mu_dble);
  203.             break;
  204.  
  205.         case as_call:
  206.             id_node   = N_AST1(node);
  207.             proc_name   = N_UNQ(id_node);
  208.             return_type = TYPE_OF(proc_name);
  209.             gen_kc(I_DUPLICATE, kind_of(return_type), "place holder");
  210.             compile(node);       /* processed from now as a procedure call */
  211.             break;
  212.  
  213.         case as_un_op:
  214.             gen_unary(node);
  215.             break;
  216.  
  217.         case as_op:
  218.             gen_binary(node);
  219.             break;
  220.  
  221.         case as_string_ivalue:
  222.             gen_value(node);
  223.             break;
  224.  
  225.         default:
  226.             compiler_error_k("GEN_ADDRESS called with kind ", node);
  227.         }
  228.     }
  229. }
  230.  
  231. /* 4.1.1: subscripting */
  232.  
  233. void gen_subscript(Node node)                                /*;gen_subscript*/
  234. {
  235.     Symbol    comp_type;
  236.     Node    index_name, array_node;
  237.     Node    index_list_node, subscript;
  238.     Tuple    index_type_list, subscripts, tup;
  239.     Symbol    array_name, array_type;
  240.     int        optimized;
  241.     int        index, seg, offset;
  242.     Fortup    ft1;
  243.  
  244. #ifdef TRACE
  245.     if (debug_flag)
  246.         gen_trace_node("GEN_SUBSCRIPT", node);
  247. #endif
  248.  
  249.     array_node = N_AST1(node);
  250.     index_list_node = N_AST2(node);
  251.     array_name = N_UNQ(array_node);
  252.     array_type = get_type(array_node);
  253.     tup = SIGNATURE(array_type);
  254.     index_type_list = (Tuple) tup[1];
  255.     comp_type = (Symbol) tup[2];
  256.     /* need tup_copy since subscripts used in tup_fromb below */
  257.     subscripts = tup_copy(N_LIST(index_list_node));
  258.  
  259.     /*
  260.      *  Before applying the brute force method of the 'do-it-all' instruction
  261.      *  "subscript", which can solve any case, some optimizations will be
  262.      *  attempted.
  263.      *
  264.      *  First, we try to compute the address of the indexed element directly,
  265.      *  when subscripts are immediate values and the index check can be done
  266.      *  at compile time:
  267.      */
  268.  
  269.     if ((Symbol)index_type_list[1] == symbol_none) {
  270.         optimized = FALSE;
  271.     }
  272.     else if (!(is_unconstrained(array_type))) {
  273.         index     = compute_index(subscripts, index_type_list);
  274.         optimized = index != -1;
  275.         if (optimized) {
  276.             if (has_static_size(comp_type)) {
  277.                 index = index * size_of(comp_type);
  278.                 if (is_simple_name(array_node) && !is_renaming(array_name) ) {
  279.                     if (is_global(array_name)) {
  280.                         reference_of(array_name);
  281.                         seg = REFERENCE_SEGMENT;
  282.                         offset = REFERENCE_OFFSET;
  283.                         /*gen_todo(I_PUSH_EFFECTIVE_ADDRESS,[seg, offset+index],
  284.                          *   array_name + '(" + str(get_ivalue(subscripts(1)))
  285.                          *      +/ [', '+str(get_ivalue(subscripts(i))):
  286.                          *                  i in [2..#subscripts] ]
  287.                          *      + ")' );
  288.                          */
  289.                         gen_rc(I_PUSH_EFFECTIVE_ADDRESS, explicit_ref_new(seg,
  290.                           offset+index), "");
  291.                     }
  292.                     else {
  293.                         gen_s(I_PUSH_EFFECTIVE_ADDRESS, array_name);
  294.                         if (index != 0)
  295.                             gen_kic(I_ADD_IMMEDIATE, mu_word, index, "offset");
  296.                     }
  297.                 }
  298.                 else {
  299.                     gen_address(array_node);
  300.                     gen_ks(I_DISCARD_ADDR, 1, array_type);
  301.                     if (index != 0)
  302.                         gen_ki(I_ADD_IMMEDIATE, mu_word, index);
  303.                 }
  304.             }
  305.             else {
  306.                 optimized = FALSE;
  307.             }
  308.         }
  309.     }
  310.     else {
  311.         optimized = FALSE;
  312.     }
  313.  
  314.     /*
  315.      *  Nothing worked, we are left with the worse case, solved by the
  316.      *  "subscript" instruction
  317.      */
  318.  
  319.     if (!optimized) {
  320.         FORTUP( index_name=(Node), index_type_list, ft1);
  321.             subscript = (Node) tup_fromb(subscripts);
  322.             gen_value(subscript) ;
  323.         ENDFORTUP(ft1);
  324.         gen_address(array_node);
  325.         gen(I_SUBSCRIPT);
  326.     }
  327.  
  328.     if (is_array_type(comp_type)) {
  329.         gen_s(I_PUSH_EFFECTIVE_ADDRESS, comp_type);
  330.     }
  331. }
  332.  
  333. int compute_index(Tuple subscript_list_arg, Tuple index_list_arg)
  334.                                                             /*;compute_index*/
  335. {
  336.     /* Evaluate mono-dimensional offset from the given subscripts */
  337.  
  338.     Node    subscript, low_node, high_node;
  339.     Symbol    indx_type;
  340.     int        ndex, delta; /* use ndex for index, index is builtin */
  341.     int         sb_val, lw_val, hg_val;
  342.     Tuple    tup;
  343.     Const    lw, hg, sb;
  344.     Tuple    subscript_list, index_list;
  345.  
  346.     /* copy arguments - needed since they are used desctructively in
  347.      * tup_frome calls below
  348.      */
  349.     subscript_list = tup_copy(subscript_list_arg);
  350.     index_list = tup_copy(index_list_arg);
  351.     ndex = 0;
  352.     delta = 1;
  353.     while (tup_size(index_list)) {
  354.         indx_type = (Symbol) tup_frome(index_list);
  355.         subscript  = (Node) tup_frome(subscript_list);
  356.         tup = SIGNATURE(indx_type);
  357.         low_node = (Node) tup[2];
  358.         high_node = (Node) tup[3];
  359.         lw = get_ivalue(low_node);
  360.         hg = get_ivalue(high_node);
  361.         sb = get_ivalue(subscript);
  362.         if (!( lw->const_kind != CONST_OM   && hg->const_kind != CONST_OM
  363.           && sb->const_kind != CONST_OM)) {
  364.             tup_free(subscript_list); 
  365.             tup_free(index_list);
  366.             return -1;
  367.         }
  368.         sb_val = INTV(sb);
  369.         lw_val = INTV(lw);
  370.         hg_val = INTV(hg);
  371.         if (sb_val<lw_val ||  sb_val>hg_val) {
  372.             /* here, raise constraint_error */
  373.             gen_s(I_LOAD_EXCEPTION_REGISTER, symbol_constraint_error);
  374.             gen(I_RAISE);
  375.             tup_free(subscript_list); 
  376.             tup_free(index_list);
  377.             return -1;
  378.         }
  379.         ndex += delta*(sb_val-lw_val);
  380.         delta *= (hg_val-lw_val+1);
  381.     }
  382.     tup_free(subscript_list); 
  383.     tup_free(index_list);
  384.     return ndex;
  385. }
  386.